module Utils where

-- The following definitions are used to make some synonyms for routines
-- in the Gofer prelude to be more Miranda compatible
shownum n = show n
hd :: [a] -> a
hd  = head                        -- in Gofer standard prelude
tl :: [a] -> [a]
tl  = tail                        -- in Gofer standard prelude
zip2 :: [a] -> [b] -> [(a,b)]
zip2  = zip                       -- in Gofer standard prelude
-- can't do anything about # = length, since # not binary.

readDec':: String -> Int
readDec' s = case readDec s of
                [(n,_)] -> n
                otherwise -> error "Not a number"

readDec = readInt 10 isDigit    (\ d -> fromEnum d - fromEnum_0)

readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt radix isDig digToInt s =
    [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
    | (ds,r) <- nonnull isDig s ]

nonnull                 :: (Char -> Bool) -> ReadS String
nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]

fromEnum_0 :: Int
fromEnum_0 = fromEnum '0'


aIsInList :: Eq a => [a] -> a -> Bool
aIsInList []  a                = False
aIsInList (x:xs) a | a == x    = True
                   | otherwise = aIsInList xs a
                   
isSpace, isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool

isSpace c  =  c == ' '  ||
              c == '\t' ||
              c == '\n' ||
              c == '\r' ||
              c == '\f' ||
              c == '\v' ||
              c == '\xa0'

isUpper c              =  c >= 'A'    && c <= 'Z'    ||
                          c >= '\xc0' && c <= '\xd6' ||
                          c >= '\xd8' && c <= '\xde'

isLower c              =  c >= 'a'   &&  c <= 'z'    ||
                          c >= '\xdf' && c <= '\xf6' ||
                          c >= '\xf8' && c <= '\xff'

isAlpha c              =  isUpper c  ||  isLower c
isDigit c              =  c >= '0'   &&  c <= '9'
isAlphaNum c           =  isAlpha c  ||  isDigit c

-- ***************************************************************************
-- *                                                                         *
-- *                          Heap                                           *
-- *                                                                         *
-- ***************************************************************************
-- module Heap where

hInitial :: Heap a
hAlloc   :: Heap a -> a -> (Heap a, Addr0)
hUpdate  :: Heap a -> Addr0 -> a -> Heap a
hFree    :: Heap a -> Addr0 -> Heap a

hLookup  :: Heap a -> Addr0 -> a
hAddresses :: Heap a -> [Addr0]
hSize    :: Heap a -> Int

hNull      :: Addr0
hIsnull    :: Addr0 -> Bool

showAddr :: Addr0 -> [Char]

type Heap a = (Int, [Int], [(Int, a)])

type Addr0   = Int

hInitial                             = (0,      [1..],  [])
hAlloc  (size, (next:free), cts) n   = ((size+1, free,   (next,n) : cts),next)
hUpdate (size, free,        cts) a n = (size,   free,   (a,n) : remove cts a)
hFree   (size, free,        cts) a   = (size-1, a:free, remove cts a)

hLookup (size,free,cts) a
 = aLookup cts a (error ("can't find node " ++ showAddr a ++ " in heap"))

hAddresses (size, free, cts) = [addr | (addr, node) <- cts]

hSize (size, free, cts) = size

hNull    = 0
hIsnull a = a == 0
showAddr a = "#" ++ shownum a         -- Print # to identify Addresses

remove :: [(Int,a)] -> Int -> [(Int,a)]
remove [] a = error ("Attempt to update or free nonexistent Address #" ++
                      shownum a)
remove ((a',n):cts) a | a == a' = cts
                      | a /= a' = (a',n) : remove cts a

-- ***************************************************************************
-- *                                                                         *
-- *                          Association                                    *
-- *                                                                         *
-- ***************************************************************************

type ASSOC a b = [(a,b)] 

-- instance (Show a,Show b) => Show (ASSOC a b) where
--    show = (show a)showList

aMapLig :: (b -> c) -> ASSOC a b -> ASSOC a c
aLookup  :: (Eq a) => ASSOC a b -> a   -> b    -> b
aLookupLs:: (Eq a) => ASSOC a b -> a   -> [b]
aIsIn    :: (Eq a) => ASSOC a b -> a   -> Bool
--aMake    :: (Eq a) => Int -> [b] -> ASSOC a b 
aDomain  ::           ASSOC a b -> [a]
aRange   ::           ASSOC a b -> [b]
aUnion   :: (Eq a) => ASSOC a b -> ASSOC a b -> ASSOC a b
aPut     :: (Eq a) => ASSOC a b -> a   -> b    -> ASSOC a b
aPutIfNot:: (Eq a) => ASSOC a b -> a   -> b    -> ASSOC a b
aModify  :: (Eq a) => ASSOC a b -> a   -> b    -> ASSOC a b
aRemoveFst :: (Eq a) => ASSOC a b -> a -> ASSOC a b
aRemove :: (Eq a) => ASSOC a b -> a -> ASSOC a b
-- aChange :: (Eq a) => ASSOC a b -> a -> b -> ASSOC a b
aEmpty   ::           ASSOC a b
aShowSep :: (Show a, Show b) => ASSOC a b -> String -> String
aShow    :: (Show a, Show b) => ASSOC a b -> String

aMapLig f [] = []
aMapLig f ((a,b):ass) = (a, f b): aMapLig f ass

aLookup []         k' def           = def
aLookup ((k,v):bs) k' def | k == k' = v
                          | k /= k' = aLookup bs k' def

aLookupLs []         k'           = []
aLookupLs ((k,v):bs) k' | k == k' = v : aLookupLs bs k'
                        | k /= k' = aLookupLs bs k'

aIsIn []         k'           = False
aIsIn ((k,v):bs) k' | k == k' = True
                    | k /= k' = aIsIn bs k'

aDomain alist = [key | (key,val) <- alist]

aRange  alist = [val | (key,val) <- alist]

aUnion ass1 ass2 = ass1 ++ ass2

aPutIfNot ass a b
    | aIsIn ass a = ass
    | otherwise = (a,b) : ass

aPut ass a b = (a,b) : ass

aModify []         k' v'           = [] -- Error not in
aModify ((k,v):bs) k' v' | k == k' = (k,v'):bs
                         | k /= k' = (k,v): aModify bs k' v'

aRemoveFst []         k'           = []
aRemoveFst ((k,v):bs) k' | k == k' = bs
                         | k /= k' = (k,v): aRemoveFst bs k'

aRemove []         k'           = []
aRemove ((k,v):bs) k' | k == k' = aRemove bs k'
                      | k /= k' = (k,v): aRemove bs k'

aEmpty = []

aShowSep [] _    = "{}"
aShowSep ((x1,x2):xs) sep = '{': (show x1 ++ sep ++ show x2 ++ showl xs)
              where showl []     = "}"
                    showl ((x1,x2):xs) = ',' : (show x1 ++ sep ++ show x2 ++ showl xs)

aShow []     = "{}"
aShow ((x1,x2):xs) = '{': (show x1 ++ "->" ++ show x2 ++ showl xs)
              where showl []     = "}"
                    showl ((x1,x2):xs) = ',' : (show x1 ++ "->" ++ show x2 ++ showl xs)


-- ***************************************************************************
-- *                                                                         *
-- *                          Set Order                                      *
-- *                                                                         *
-- ***************************************************************************

-- module SetOrd where
-- import Sort
-- -- Set ordered without repetition


setFromList     :: (Ord a) => [a]     -> Set a
setToList       :: (Ord a) => Set a   -> [a]
setUnion        :: (Ord a) => Set a   -> Set a -> Set a
setPut          :: (Ord a) => Set a   -> a     -> Set a
setEliminate    :: (Ord a) => Set a   -> a     -> Set a
setIntersection :: (Ord a) => Set a   -> Set a -> Set a
setSubtraction  :: (Ord a) => Set a   -> Set a -> Set a
setElementOf    :: (Ord a) => a       -> Set a -> Bool
setEmpty        :: (Ord a) => Set a
setIsEmpty      :: (Ord a) => Set a   -> Bool
setSingleton    :: (Ord a) => a       -> Set a
setUnionList    :: (Ord a) => [Set a] -> Set a
setShow         :: (Show a) => Set a   -> String

type Set a = [a]           -- Ordered by the sort function

-- instance Show a => Show (Set a) where
setShow []     = "{}"
setShow (x:xs) = '{': (show x ++ showl xs)
              where showl []     = "}"
                    showl (x:xs) = ',' : (show x ++ showl xs)


setEmpty = []
setIsEmpty s = null s
setSingleton x = [x]

setFromList = rmdup . sort
                  where rmdup []       = []
                        rmdup [x]      = [x]
                        rmdup (x:y:xs) | x == y = rmdup (y:xs)
                                       | x /= y = x: rmdup (y:xs)

setToList xs = xs

setUnion []     []            = []
setUnion []     (b:bs)        = (b:bs)
setUnion (a:as) []            = (a:as)
setUnion (a:as) (b:bs) | a <  b  = a: setUnion as (b:bs)
                       | a == b  = a: setUnion as bs
                       | a >  b  = b: setUnion (a:as) bs

setPut [] b = [b]
setPut s1@(a:as) b | a <  b  = a: setPut as b
                   | a == b  = s1
                   | a >  b  = b: s1

setEliminate [] b = []
setEliminate s1@(a:as) b
                   | a <  b  = a: setEliminate as b
                   | a == b  = as
                   | a >  b  = s1

setIntersection []     []     = []
setIntersection []     (b:bs) = []
setIntersection (a:as) []     = []
setIntersection (a:as) (b:bs) | a <  b = setIntersection as (b:bs)
                              | a == b = a: setIntersection as bs
                              | a >  b = setIntersection (a:as) bs

setSubtraction []     []      = []
setSubtraction []     (b:bs)  = []
setSubtraction (a:as) []      = (a:as)
setSubtraction (a:as) (b:bs) | a <  b  = a: setSubtraction as (b:bs)
                             | a == b  = setSubtraction as bs
                             | a > b   = setSubtraction (a:as) bs

setElementOf = elem

setUnionList = foldl setUnion setEmpty


-- ***************************************************************************
-- *                                                                         *
-- *                          Utils                                          *
-- *                                                                         *
-- ***************************************************************************

getName  :: NameSupply -> [Char]   -> (NameSupply, [Char])
getNames :: NameSupply -> [[Char]] -> (NameSupply, [[Char]])
initialNameSupply :: NameSupply

type NameSupply = Int
initialNameSupply = 0
getName name_supply prefix = (name_supply+1, makeName prefix name_supply)
getNames name_supply prefixes
 = (name_supply + length prefixes, zipWith makeName prefixes [name_supply..])
getXNames = map (makeName "x_") [0..]

makeName prefix ns = prefix ++ "_" ++ shownum ns

first (a,b) = a
second (a,b) = b
seventh (a,b,c,d,e,f,g,h) = g

-- zipWith is defined in standard prelude

foldll :: (a -> b -> a) -> a -> [b] -> a
foldll = foldl                       -- in Gofer standard prelude.

mapAccuml :: (a -> b -> (a, c)) -- Function of accumulator and element
                                --   input list, returning new
                                --   accumulator and element of result list
             -> a               -- Initial accumulator
             -> [b]             -- Input list
             -> (a, [c])        -- Final accumulator and result list

mapAccuml f acc []     = (acc, [])
mapAccuml f acc (x:xs) = (acc2, x':xs')
                         where (acc1, x')  = f acc x
                               (acc2, xs') = mapAccuml f acc1 xs
-- module Sort where
sort [] = []
sort [x] = [x]
sort (x:xs) = (sort [ y | y <- xs, y < x]) ++ x : sort [ y | y <- xs, y >= x ]

space n = take n (repeat ' ')
toList x = [x]

rmLast :: [a] -> [a]
rmLast ls = take ((length ls)-1) ls

spanL :: ([a] -> Bool) -> [a] -> ([a], [a])
spanL _ xs@[]              =  (xs, xs)
spanL p xs@(x:xs')
      | p xs = let (ys,zs) = spanL p xs' in (x:ys,zs)
      | otherwise          =  ([],xs)

breakL :: ([a] -> Bool) -> [a] -> ([a], [a])
-- breakL p                 =  spanL (not . p)
breakL _ xs@[]           =  (xs, xs)
breakL p xs@(x:xs')
           | p xs        =  ([],xs)
           | otherwise   =  let (ys,zs) = breakL p xs' in (x:ys,zs)

dropLWhile :: ([a] -> Bool) -> [a] -> [a]
dropLWhile f ls
      | f ls = dropLWhile f (tail ls)
      | otherwise = ls

mapAccumList :: Ord a => (b -> ([a], c)) -- Function element
                                -- input list, returning 
                                -- accumulator and element of result list
                -> [b]          -- Input list
                -> ([a], [c])   -- Final accumulator and result list

mapAccumList f []     = ([], [])
mapAccumList f (x:xs) = (acc3, x':xs')
                         where (acc1, x')  = f x
                               (acc2, xs') = mapAccumList f xs
                               acc3 = setUnion acc1 acc2


yesAndNo             :: (a -> Bool) -> [a] -> ([a],[a])
yesAndNo p []            = ([],[])
yesAndNo p (x:xs) 
            | p x       =  (x:ys,  zs) 
            | otherwise =  (  ys,x:zs)
                           where (ys,zs) = yesAndNo p xs
